home *** CD-ROM | disk | FTP | other *** search
/ TOS Silver 2000 / TOS Silver 2000.iso / programm / MM2_DEV / S / MYUTIL / MARIO.M < prev    next >
Encoding:
Text File  |  1991-03-26  |  8.8 KB  |  365 lines
  1.  
  2. MODULE Mario;
  3.  
  4. (* Erstellt: tt 26.2.88 nach Listing v. Turbo 4.0 / MSDOS v. cd
  5.  
  6. *)
  7.  
  8. FROM VDIOutputs IMPORT Mark;
  9. FROM VDIAttributes IMPORT DefineColor, SetMarkerColor;
  10. FROM VDIInquires IMPORT GetColorDef;
  11. FROM GrafBase IMPORT Point;
  12. FROM GEMEnv IMPORT DeviceParameter, PtrDevParm, DeviceHandle, InitGem, RC;
  13.  
  14. FROM SYSTEM IMPORT
  15.         ADDRESS;
  16.  
  17. FROM Storage IMPORT
  18.         ALLOCATE;
  19.  
  20. FROM InOut IMPORT
  21.         WriteString, WriteLn, WriteHex, WriteReal, GotoXY, ReadReal, Done,
  22.         FlushKbd, Read, BusyRead, ReadCard, WritePg, WriteFix, ReadString,
  23.         WriteCard;
  24.  
  25. FROM Strings IMPORT
  26.         Empty, Length, Upper;
  27.  
  28. IMPORT MathLib0, Files, Binary;
  29.  
  30.  
  31. CONST
  32.         x_start     = 0.35;
  33.         zoom        = 5000;
  34.         fname       = '\MARIO.IMG';
  35.  
  36. TYPE
  37.         seqrange = [1..79];
  38.  
  39. VAR
  40.         conv_crit: LONGREAL;
  41.         sequence: ARRAY seqrange OF CHAR;
  42.         seqlen: seqrange;
  43.         
  44.         a_min, a_max, b_min, b_max: LONGREAL;
  45.         x_points, y_points: CARDINAL;
  46.  
  47.  
  48. MODULE math;
  49. (*$R-*)
  50.  
  51.   IMPORT
  52.         seqrange, x_start, conv_crit, sequence, seqlen;
  53.  
  54.   FROM MathLib0 IMPORT
  55.         ln;
  56.  
  57.   EXPORT
  58.         lyapunow;
  59.  
  60.   VAR
  61.         iteration: LONGCARD;
  62.         sum: LONGREAL;
  63.         quer, quer_alt: LONGREAL;
  64.         conv: LONGREAL;
  65.  
  66.         ln2: LONGREAL;
  67.  
  68.   PROCEDURE poincare (r, x: LONGREAL): LONGREAL;
  69.     BEGIN
  70.       RETURN r * x * (1.-x)
  71.     END poincare;
  72.  
  73.   PROCEDURE dpc (r, x: LONGREAL): LONGREAL;
  74.     BEGIN
  75.       RETURN r - 2. * r * x
  76.     END dpc;
  77.  
  78.   PROCEDURE quer_conv (log: LONGREAL; VAR quer, conv: LONGREAL);
  79.     BEGIN
  80.       sum:= sum + log;
  81.       quer:= sum / LFLOAT (iteration);
  82.       conv:= ABS (quer - quer_alt);
  83.       quer_alt:= quer
  84.     END quer_conv;
  85.  
  86.   PROCEDURE lyapunow (a, b: LONGREAL): LONGREAL;
  87.     
  88.     VAR
  89.         (*$Reg*)conv_alt,
  90.         (*$Reg*)x,
  91.         (*$Reg*)x_alt,
  92.         (*$Reg*)r,
  93.         (*$Reg*)abl: LONGREAL;
  94.         seqidx: seqrange;
  95.         
  96.     BEGIN
  97.       x_alt:= x_start;
  98.       sum:= 0.;
  99.       quer_alt:= 0.;
  100.       conv:= conv_crit * 2.;
  101.       iteration:= 0;
  102.       REPEAT
  103.         FOR seqidx:= 1 TO seqlen DO
  104.           IF sequence [seqidx] = 'A' THEN r:= a ELSE r:= b END;
  105.           INC (iteration);
  106.           conv_alt:= conv;
  107.           (*x:= poincare (r, x_alt);*)
  108.           x:= r * x_alt * (1.-x_alt);
  109.           (*abl:= ABS (dpc (r, x_alt));*)
  110.           abl:= ABS (r - 2. * r * x_alt);
  111.           IF abl # 0. THEN
  112.             (*quer_conv (ln (abl) / ln2, quer, conv);*)
  113.             sum:= sum + ln (abl) / ln2;
  114.             quer:= sum / LFLOAT (iteration);
  115.             conv:= ABS (quer - quer_alt);
  116.             quer_alt:= quer
  117.           ELSE
  118.             quer:= 0.;
  119.             conv:= -200000.0
  120.           END;
  121.           x_alt:= x
  122.         END
  123.       UNTIL (conv < conv_crit) AND (conv_alt < conv_crit);
  124.       RETURN quer
  125.     END lyapunow;
  126.  
  127.   BEGIN
  128.     ln2:= ln (2.)
  129.   END (* module *) math;
  130. (*$R+*)
  131.  
  132.  
  133. PROCEDURE input (): BOOLEAN;
  134.   VAR i: CARDINAL;
  135.   BEGIN
  136.     WritePg;
  137.     a_min:= 3.825;
  138.     b_min:= 3.825;
  139.     a_max:= 3.86;
  140.     b_max:= 3.86;
  141.     x_points:= 50;
  142.     y_points:= 50;
  143.     conv_crit:= 0.001;
  144.     sequence:= 'AABBAB';
  145.     (*
  146.     WriteString ('min (A)  ? ');
  147.     ReadReal (a_min);
  148.     IF ~Done THEN RETURN FALSE END;
  149.     WriteString ('max (A)  ? ');
  150.     ReadReal (a_max);
  151.     IF ~Done THEN RETURN FALSE END;
  152.     WriteString ('min (B)  ? ');
  153.     ReadReal (b_min);
  154.     IF ~Done THEN RETURN FALSE END;
  155.     WriteString ('max (B)  ? ');
  156.     ReadReal (b_max);
  157.     IF ~Done THEN RETURN FALSE END;
  158.     WriteString ('n (A)    ? ');
  159.     ReadCard (x_points);
  160.     IF ~Done THEN RETURN FALSE END;
  161.     WriteString ('n (B)    ? ');
  162.     ReadCard (y_points);
  163.     IF ~Done THEN RETURN FALSE END;
  164.     WriteString ('conv     ? ');
  165.     ReadReal (conv_crit);
  166.     IF ~Done THEN RETURN FALSE END;
  167.     WriteString ('sequence ? ');
  168.     ReadString (sequence);
  169.     IF Length (sequence) < 2 THEN RETURN FALSE END;
  170.     Upper (sequence);
  171.     FOR i:= 1 TO Length (sequence) DO
  172.       IF (sequence [i] # 'A') AND (sequence [i] # 'B') THEN RETURN FALSE END
  173.     END;
  174.     *)
  175.     RETURN TRUE
  176.   END input;
  177.  
  178.  
  179. PROCEDURE stop (): BOOLEAN;
  180.   VAR ch: CHAR;
  181.   BEGIN
  182.     BusyRead (ch);
  183.     RETURN ch = 33C
  184.   END stop;
  185.  
  186.  
  187. VAR
  188.         a_inc, b_inc: LONGREAL;
  189.         a, b: LONGREAL;
  190.         x, y: CARDINAL;
  191.         lyap: LONGREAL;
  192.  
  193.         point, image: POINTER TO INTEGER;
  194.         v: LONGINT;
  195.         vs: INTEGER;
  196.  
  197.         ch: CHAR;
  198.  
  199. PROCEDURE init (): BOOLEAN;
  200.   BEGIN
  201.     a_inc:= (a_max-a_min) / LFLOAT (x_points);
  202.     b_inc:= (b_max-b_min) / LFLOAT (y_points);
  203.     seqlen:= Length (sequence);
  204.     ALLOCATE (image, SIZE (image^) * LONG (x_points) * LONG (y_points));
  205.     RETURN image # NIL
  206.   END init;
  207.  
  208. PROCEDURE saveImage;
  209.  
  210.   VAR f: Files.File;
  211.  
  212.   PROCEDURE err (): BOOLEAN;
  213.     BEGIN
  214.       IF Files.State (f) < 0 THEN
  215.         WriteLn;
  216.         WriteString ('Write error !');
  217.         Files.ResetState (f);
  218.         Files.Close (f);
  219.         RETURN TRUE
  220.       ELSE
  221.         RETURN FALSE
  222.       END
  223.     END err;
  224.  
  225.   VAR card: CARDINAL;
  226.  
  227.   BEGIN
  228.     WriteLn;
  229.     WriteString ('Writing image...');
  230.     Files.Create (f, fname, Files.writeOnly, Files.replaceOld);
  231.     IF err () THEN RETURN END;
  232.     card:= 12345;
  233.     Binary.WriteBlock (f, card);
  234.     IF err () THEN RETURN END;
  235.     Binary.WriteBlock (f, x_points);
  236.     IF err () THEN RETURN END;
  237.     Binary.WriteBlock (f, y_points);
  238.     IF err () THEN RETURN END;
  239.     card:= SHORT (SIZE (image^));
  240.     Binary.WriteBlock (f, card);
  241.     IF err () THEN RETURN END;
  242.     card:= zoom;
  243.     Binary.WriteBlock (f, card);
  244.     IF err () THEN RETURN END;
  245.     Binary.WriteBytes (f, image, LONGCARD (ADDRESS (point) - ADDRESS (image)));
  246.     IF err () THEN RETURN END;
  247.     Files.Close (f);
  248.     IF err () THEN RETURN END;
  249.     WriteString (' OK.');
  250.   END saveImage;
  251.  
  252. PROCEDURE showPos (x,y:CARDINAL);
  253.   BEGIN
  254.     GotoXY (0, 12);
  255.     WriteString ('  x    y');
  256.     WriteLn;
  257.     WriteCard (x,4);
  258.     WriteCard (y,5);
  259.   END showPos;
  260.  
  261. PROCEDURE showLyap;
  262.   BEGIN
  263.     WriteLn;
  264.     WriteReal (lyap,3,8);
  265.   END showLyap;
  266.  
  267. VAR ok: BOOLEAN;
  268.     dh: DeviceHandle;
  269.     dp: PtrDevParm;
  270.     n: CARDINAL;
  271.     r,g,b0:ARRAY [0..1023] OF CARDINAL;
  272.  
  273. PROCEDURE rstcol;
  274.   VAR ch: CHAR; n: CARDINAL;
  275.   BEGIN
  276.     FOR n:= 0 TO dp^.noColors-1 DO
  277.       DefineColor (dh, n, r[n],g[n],b0[n])
  278.     END;
  279.   END rstcol;
  280.  
  281. PROCEDURE finish;
  282.   VAR ch: CHAR; n: CARDINAL;
  283.   BEGIN
  284.     WriteLn;
  285.     WriteString ('Press a key to end...');
  286.     FlushKbd;
  287.     Read (ch);
  288.   END finish;
  289.  
  290.  
  291. BEGIN
  292.   IF input () AND init () THEN
  293.     InitGem (RC, dh, ok);
  294.     IF NOT ok THEN HALT END;
  295.     
  296.     dp:= DeviceParameter (dh);
  297.     
  298.     FOR n:= 0 TO dp^.noColors-1 DO
  299.       GetColorDef (dh, n, FALSE, r[n],g[n],b0[n])
  300.     END;
  301.     FOR n:= 0 TO 127 DO
  302.       DefineColor (dh, n, n*8, 0, 0);
  303.     END;
  304.     FOR n:= 0 TO 127 DO
  305.       DefineColor (dh, n+128, 0, n*8, 0);
  306.     END;
  307.     
  308.     point:= image;
  309.     b:= b_min;
  310.     FOR y:= 1 TO y_points DO
  311.       a:= a_min;
  312.       FOR x:= 1 TO x_points DO
  313.         lyap:= lyapunow (a,b);
  314.         (*
  315.         showPos (x,y);
  316.         showLyap;
  317.         *)
  318.         (*
  319.         IF lyap # 0.0 THEN
  320.           v:= MathLib0.entier (lyap * LFLOAT (zoom));
  321.           IF v = 0L THEN
  322.             IF lyap < 0. THEN v:= MinInt ELSE v:= MaxInt END
  323.           END
  324.         ELSE
  325.           v:= 0
  326.         END;
  327.         IF v < 0L THEN
  328.           IF v < LONG (MinInt) THEN v:= MinInt END
  329.         ELSE
  330.           IF v < LONG (MaxInt) THEN v:= MaxInt END
  331.         END;
  332.         point^:= SHORT (v);
  333.         INC (point, SHORT (SIZE (point^)));
  334.         *)
  335.         (*
  336.         WriteCard (y,5);
  337.         WriteCard (x,5);
  338.         WriteInt (v, 10);
  339.         WriteLn;
  340.         *)
  341.         vs:= VAL (INTEGER,lyap * LFLOAT (128));
  342.         IF vs < 0 THEN
  343.           IF vs < -128 THEN vs:= -128 END;
  344.           (*vs:= -(129-INTEGER(ABS(vs)))*)
  345.         ELSE
  346.           IF vs > 127 THEN vs:= 127 END;
  347.           (*vs:= 127-vs*)
  348.         END;
  349.         SetMarkerColor (dh, vs+128);
  350.         Mark (dh, Point {x,y});
  351.         a:= a + a_inc;
  352.         IF stop () THEN rstcol; RETURN END
  353.       END;
  354.       b:= b + b_inc
  355.     END;
  356.     (*
  357.     saveImage;
  358.     *)
  359.   END;
  360.   finish;
  361.   rstcol
  362. END Mario.
  363. ə
  364. (* $000011FE$00000C07$00001EE9$FFF3BAC1$FFF3BAC1$FFF3BAC1$FFF3BAC1$FFF3BAC1$FFF3BAC1$FFF3BAC1$FFF3BAC1$FFF3BAC1$FFF3BAC1$FFF3BAC1$FFF3BAC1$FFF990DA$FFF3BAC1$FFF3BAC1$FFF3BAC1$FFF3BAC1$FFF3BAC1$FFF3BAC1$FFF3BAC1$FFF3BAC1$FFF3BAC1$FFF3BAC1$FFF3BAC1$FFF3BAC1$FFF3BAC1$FFF3BAC1$FFF3BAC1$FFF3BAC1$FFF3BAC1$FFF3BAC1$FFF3BAC1$FFF3BAC1$FFF3BAC1$FFF3BAC1$FFF3BAC1$FFF3BAC1$FFF3BAC1$FFF3BAC1Ç$00001A90T.......T.......T.......T.......T.......T.......T.......T.......T.......T.......$00000416$00000BB6$000018C0$00001A90$00000119$00001AAB$00001A90$000011BB$00001897$00001ACC$FFEB9CC2$FFEB9CC2$FFEB9CC2$0000192F$00000011$00000422ÉÇÇ*)
  365.